home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BMUG Revelations
/
BMUG Revelations.toast
/
Programming
/
Programming Languages
/
Yerk 3.64
/
Float source
/
fltMem
< prev
next >
Wrap
Text File
|
1990-12-22
|
8KB
|
243 lines
\ Memory manager for floating point heap
\ 9/01/85 cbd Version 1.0
\ 9/24/87 rfl fixed f2dup
\ The floating heap is a region of heap that is divided into 12-byte
\ blocks. Each block consists of two bytes of status information, along
\ with 10 bytes of data. If the 0 bit of the status field is on, the block
\ is in use. Otherwise, the status field holds the offset of the next
\ free block from the start of the array, and the 0 bit is off because
\ the offset must be even.
\ execWord provides an interface from code to a high-level word.
\ If the word completes, it will return to the point in the last
\ high-level word that was executed before the code was invoked.
\ the contents of D0 and D1 are placed on the stack, and the offset
\ of the executed word must be in D7. It can't have named parms.
:CODE execWord
move.l a4,-(a7) ; save old IP on the return stack
lea 0(a3,d7.l),a4 ; set up the IP
move.l d0,-(a7) ; push parameters and do a NEXT
move.l d1,-(a7)
;CODE
\ floating-point error handler
: fpErr SELECT{
0 IS{ type }END \ print msg and return to caller
1 IS{ cr ." Floating point heap is full." abort }END
2 IS{ cr ." Not a Float:" . abort }END
3 IS{ cr ." Uninitialized float argument" abort }END
Default{ cr ." Undefined floating point error code" abort
}SELECT ;
\ Code-based NEW: method for speed
:CODE fltNew
move.l d5,a2 ; get mstack
movea.l (A2),a0 ; get obj addr
adda.l a3,a0 ; a0 = absolute addr
clr.l d7
move.w 0(a0),d7 ; d7 = offset of first free block
beq fullErr
move.w 0(a0,d7.l),d0 ; d0 = addr of next free block
move.w d0,0(a0) ; Put in free head ptr
move.w #1,0(a0,d7.l) ; mark in use
add.l (a2),d7 ; get rel addr of the block
move.l d7,-(A7)
move.l (a4)+,d6 ; next
move.l 0(a3,d6.l),d7
jmp 0(a3,d7.l)
fullErr move.l #1,d1 ; code for err handler
move.l YERK[fpErr],d7
move.l YERK[execWord],d6
jmp 0(a3,d6.l)
;CODE
\ return a float block to the free list - code method
:CODE fltDisp
move.l (A7)+,a1 ; a0 = flt rel addr
adda.l a3,a1 ; absolute
move.l d5,a2 ; get mstack
move.l (a2),a0 ; get receiver
adda.l a3,a0 ; absolute receiver addr
move.w (a0),d7 ; next free block offset
move.w d7,(a1) ; store link in free block
sub.l a0,a1 ; get offs of free block
move.w a1,(a0) ; store in free head ptr
;CODE
\ because of assumptions made by code-based methods, this
\ class CANNOT be used to create instance variables.
:CLASS fltHeap <Super Object 12 <Indexed
Int FreeHead \ offset of first free block
\ set all blocks to free and link together.
:M INIT: limit 1- 0
DO I 1+ (^elem) copyM - I (^elem) w! LOOP
0 limit 1- (^elem) w! 0 (^elem) copym - put: freeHead ;M
\ ( -- fPtr ) return a ptr to a new block
:M NEW: fltNew ;M
\ return # of float blocks remaining in float heap
:M ROOM: { \ offs #free -- #free } get: freeHead -> offs 0 -> #free
BEGIN
offs 0> offs 1 and not and
WHILE offs copyM + w@ -> offs 1 ++> #free
REPEAT #free ;M
\ ( fptr -- ) dispose of block for fptr
:M DISPOSE: fltDisp ;M
;CLASS
100 fltHeap fltMem
init: fltMem
\ subroutine returns new float block ptr in d1
\ destroys A0
:CODE (fltNew)
move.l YERK[fltMem],a0
add.l a3,a0
clr.l d1
move.w (a0),d1 ; d1 = offset of first free block
beq fullErr1
move.w 0(a0,d1.l),(a0) ; store new free head ptr
move.w #1,0(a0,d1.l) ; mark in use
suba.l a3,a0 ; relative again
add.l a0,d1 ; get rel addr of the block
rts
fullerr1 move.l #1,d1 ; code for err handler
move.l YERK[fpErr],d7
move.l YERK[execWord],d6
jmp 0(a3,d6.l)
;CODE
\ dispose of the float in D0 - subroutine. Destroys A0,A1, clears D0
:CODE (fltDisp)
move.l d0,a1
beq noFloat
andi.l #4278190081,d0 ; $FF000001 range check
bne noFloat ; value is not a float
adda.l a3,a1 ; absolute addr of float
move.l YERK[fltMem],a0
add.l a3,a0
move.w (a0),(a1) ; next free block offset
sub.l a0,a1 ; get offs of free block
move.w a1,(a0) ; store in free head ptr
rts
noFloat move.l #2,d1 ; code for err handler
move.l a1,d0 ; value of offending number
move.l YERK[fpErr],d7
move.l YERK[execWord],d6
jmp 0(a3,d6.l)
;CODE
\ subroutine disposes of floats in d0,d1
\ destroys A0, A1
:CODE (fltDisp2)
move.l d0,a1
beq noFloat1
andi.l #4278190081,d0 ; $FF000001 range check
bne noFloat1 ; value is not a float
adda.l a3,a1 ; absolute
move.l YERK[fltMem],a0 ; a0 = float heap ptr
adda.l a3,a0 ; absolute
move.w (a0),(a1) ; next free block offset
sub.l a0,a1 ; get offs of free block
move.w a1,d0 ; save
move.l d1,a1 ; now do the other one
beq noFloat1
andi.l #4278190081,d1 ; $FF000001 range check
bne noFloat1 ; value is not a float
adda.l a3,a1 ; absolute
move.w d0,(a1) ; next free block offset
sub.l a0,a1 ; get offs of free block
move.w a1,(a0) ; store in free head ptr
rts
noFloat1 move.l #2,d1 ; code for err handler
move.l a1,d0 ; value of offending number
move.l YERK[fpErr],d7
move.l YERK[execWord],d6
jmp 0(a3,d6.l)
;CODE
:CODE fLit
move.l YERK[(fltNew)],d7
jsr 0(a3,d7.l) ; get new float in d1
move.l (a4)+,2(a3,d1.l) ; move float data at IP to new block
move.l (a4)+,6(a3,d1.l)
move.w (a4)+,10(a3,d1.l)
move.l d1,-(a7) ; push the new float
;CODE
:CODE fDup
move.l YERK[(fltNew)],d7
jsr 0(a3,d7.l) ; get new float in d1
move.l (A7),d0 ; get float to dup
lea 2(a3,d0.l),a0
lea 2(a3,d1.l),a1
move.l (a0)+,(a1)+
move.l (a0)+,(a1)+
move.w (a0)+,(a1)+
move.l d1,-(a7) ; push the new float
;CODE
\ dup the top two floats on the stack
:CODE f2Dup
move.l (A7),d0 ; get float to dup
move.l YERK[(fltNew)],d7
jsr 0(a3,d7.l) ; get new float in d1
lea 2(a3,d0.l),a0
lea 2(a3,d1.l),a1
move.l (a0)+,(a1)+
move.l (a0)+,(a1)+
move.w (a0)+,(a1)+
move.l d1,d2 ; save the new float
move.l 4(a7),d0
move.l YERK[(fltNew)],d7
jsr 0(a3,d7.l) ; get another float
lea 2(a3,d0.l),a0
lea 2(a3,d1.l),a1
move.l (a0)+,(a1)+
move.l (a0)+,(a1)+
move.w (a0)+,(a1)+
move.l d1,-(a7) ; push bottom element
move.l d2,-(a7)
;CODE
:CODE fOver
move.l 4(A7),d0 ; get float to dup
move.l YERK[(fltNew)],d7
jsr 0(a3,d7.l) ; get new float in d1
lea 2(a3,d0.l),a0
lea 2(a3,d1.l),a1
move.l (a0)+,(a1)+
move.l (a0)+,(a1)+
move.w (a0)+,(a1)+
move.l d1,-(a7) ; push the new float
;CODE
:CODE fDrop
move.l (A7)+,d0
move.l YERK[(fltDisp)],d7
jsr 0(a3,d7.l) ; dispose of float in D0
;CODE
:CODE f2Drop
move.l (A7)+,d0
move.l (a7)+,d1
move.l YERK[(fltDisp2)],d7
jsr 0(a3,d7.l) ; dispose of float in D0
;CODE
( ops opCode -- )
\ Call FP68K. Floating-point package.
: fp68k makeint call pack4 ;
\ Call ELEMS68K. Transcendentals package.
: elems68k makeint call pack5 ;